home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-19 / jan93cad.zip / TIP831.LSP < prev    next >
Lisp/Scheme  |  1993-02-12  |  3KB  |  88 lines
  1. ; TIP #831: ARROW.LSP (c)1993, Walter J. Reini
  2.  
  3. ; ARROW.LSP inserts an arrow on to the drawing 
  4. ; and allows four (4) lines of text comments to be entered.    
  5.  
  6. (defun C:ARROW()
  7.   (setq #DWGSC 1.0)                                            
  8.   (setq $LAYER (getvar "clayer"))
  9.   (command "style" "std1-8" "simplex" (* 0.125 #DWGSC) "" "" "" "" "")  
  10.   (command "layer" "make" "arrow"                                    
  11.            "color" "red" "" "")                            
  12.   (setq INSPT (getpoint "\nEnter insertion point:"))                 
  13.   (command "insert" "arrow" INSPT #DWGSC #DWGSC pause)               
  14.   (command "explode" "last")                                         
  15.   (setq SS1 (ssget "X" (list (cons 0 "POINT")                         
  16.   (cons 8 "arrow"))))
  17.   (if SS1
  18.     (progn
  19.       (setq COUNT 0
  20.         PMAX (sslength SS1)                                    
  21.         $TXTEVAL (getvar "TEXTEVAL")
  22.       );setq
  23.       (setvar "TEXTEVAL" 1)
  24.       (while (< COUNT PMAX)
  25.         (setq EN (ssname SS1 COUNT)
  26.           ED (entget EN)
  27.           BLKN (dxf 2 ED)
  28.         );setq
  29.         (if (= COUNT 0)                                        
  30.           (progn
  31.             (setq PT1 (dxf 10 ED)                              
  32.               X1 (nth 0 (dxf 10 ED))                         
  33.               Y1 (nth 1 (dxf 10 ED))                         
  34.             );setq
  35.           );progn
  36.           (princ)
  37.         );if
  38.         (if (= COUNT 1)                                    
  39.           (progn
  40.             (setq PT0 (dxf 10 ED)                                 
  41.               X0 (nth 0 (dxf 10 ED))                       
  42.               Y0 (nth 1 (dxf 10 ED))                       
  43.             );setq
  44.           );progn
  45.           (princ)
  46.         );if
  47.         (setq COUNT (+ COUNT 1))
  48.       );while
  49.       (setq THETA (angtos (angle PT0 PT1) 0 2))            
  50.       (setq ANG (atof THETA))                              
  51.       (setq ETA (angle PT0 PT1))                           
  52.     );progn
  53.     (princ)
  54.   );ss1
  55.   (command "erase" SS1 "")                                 
  56.   (princ "\nEnter text:")
  57.   (if (<= ANG 90)
  58.     (command "dtext" "style" "std1-8" "justify" "fit" PT0 PT1)
  59.     (cond 
  60.       ((> ANG 270) (command "dtext" "Style" "STD1-8" 
  61.                     "Justify" "fit" PT0 PT1))
  62.       (ANG 
  63.         (progn
  64.  
  65.           ; else if
  66.           (setq TX0 (+ X0 (* (* 0.5155 #DWGSC) (cos (- ETA (/ pi 2)))))
  67.             TY0 (+ Y0 (* (* 0.5155 #DWGSC) (sin (- ETA (/ pi 2)))))
  68.             TX1 (+ X1 (* (* 0.5155 #DWGSC) (cos (- ETA (/ pi 2)))))
  69.             TY1 (+ Y1 (* (* 0.5155 #DWGSC) (sin (- ETA (/ pi 2)))))
  70.             TPT0 (list TX1 TY1)
  71.             TPT1 (list TX0 TY0)
  72.           );setq
  73.           (command "dtext" "style" "std1-8" "justify" "fit" TPT0 TPT1)
  74.           (princ)
  75.       ));progn
  76.     );cond
  77.  
  78.   );if <=90
  79.   (command "layer" "set" $LAYER "")
  80.   (princ)      
  81. );defun  
  82.  
  83. (defun dxf (code elist)
  84.   (cdr (assoc code elist))
  85. );defun  
  86. ;end arrow.lsp
  87.  
  88.